home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 012a / lib194.zip / MISC.PRG < prev    next >
Text File  |  1993-01-08  |  53KB  |  1,408 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: MISC.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are the miscellaneous functions/procedures from the PROC
  6. *--             file that aren't as commonly used as the others. See README.TXT
  7. *--             for details on how to use this library file.
  8. *--             The following functions have been copied from the appropriate
  9. *--             library files, and may be deleted if this program is simply
  10. *--             copied into the PROC.PRG file with STRINGS.PRG and CONVERT.PRG
  11. *--             files:
  12. *--             ATCOUNT() (from STRINGS.PRG)
  13. *--             DEC2HEX() (from CONVERT.PRG)
  14. *--             STRPBRK() (from STRINGS.PRG)
  15. *-------------------------------------------------------------------------------
  16.  
  17. FUNCTION PlayIt
  18. *-------------------------------------------------------------------------------
  19. *-- Programmer..: Mike Carlisle (A-T)
  20. *-- Date........: 01/21/1992
  21. *-- Notes.......: This function (from Technotes, issue??) will play a song
  22. *--               stored in a memory variable (array).
  23. *--               This is a two dimensional array, with the first dimension
  24. *--               defined being the # of notes, each note having two parts.
  25. *--               For a song with 12 notes, the declare statement is:
  26. *--                 DECLARE aSong[12,2]
  27. *--               aSong[1,1] is the pitch of the first note.
  28. *--               aSong[1,2] is the duration of the first note.
  29. *--               Pitches are defined from C below Middle C to B below Middle C.
  30. *--               These are from a "tempered" scale. Values can be raised an
  31. *--               octave by doubling the number, lowered by halving it.
  32. *--               Duration can be from 1 to 20.
  33. *--                           Note   Value
  34. *--                           C      261
  35. *--                           C#     277
  36. *--                           D      294
  37. *--                           D#     311
  38. *--                           E      329
  39. *--                           F      349
  40. *--                           F#     370
  41. *--                           G      392
  42. *--                           G#     415
  43. *--                           A      440
  44. *--                           A#     466
  45. *--                           B      494
  46. *-- Written for.: dBASE IV, 1.1
  47. *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to choose
  48. *--               the song to be played. This alleviates the need for the
  49. *--               procedures SONG1 and SONG2 and the memfile created by them.
  50. *--               Two songs are provided (see below) ...
  51. *-- Calls.......: None
  52. *-- Called by...: Any
  53. *-- Usage.......: PlayIt(<nSong>)
  54. *-- Example.....: @5,10 say "Enter last name: " get lName valid required
  55. *--                      .not. empty(lName);
  56. *--                      error PlayIt(1)+"There must be a lastname ..."
  57. *--               Read
  58. *--                 && OR
  59. *--               ?? PlayIt(2)
  60. *-- Returns.....: Nul (or Beep on invalid parameter)
  61. *-- Parameters..: nSong = Song number. Programmer might consider adding to the
  62. *--                       list below for any songs added for documentation
  63. *--                       purposes ...
  64. *--                       VALID VALUES/SONGS:
  65. *--                         1  =  Dirge
  66. *--                         2  =  "Touchdown"
  67. *-------------------------------------------------------------------------------
  68.  
  69.     parameter nSong
  70.     private aSong, nCounter
  71.     
  72.     *-- check for valid type of parameter ... must be numeric ...
  73.     if .not. type("nSong") $ "NF"
  74.         return chr(7)
  75.     endif
  76.     
  77.     *-- get the integer value of nSong ... in case someone tries a "fast one"
  78.     nSong = int(nSong)
  79.     
  80.     *-- load song
  81.     do case
  82.         case nSong = 1  && dirge
  83.             declare aSong[12,2]          && 12 notes, 2 parts each
  84.             store 220     to aSong[1,1]  && pitch
  85.             store  10     to aSong[1,2]  && duration
  86.             store 220     to aSong[2,1]
  87.             store  10     to aSong[2,2]
  88.             store 220     to aSong[3,1]
  89.             store   2     to aSong[3,2]
  90.             store 220     to aSong[4,1]
  91.             store  10     to aSong[4,2]
  92.             store 261.63  to aSong[5,1]
  93.             store   7     to aSong[5,2]
  94.             store 246.94  to aSong[6,1]
  95.             store   2     to aSong[6,2]
  96.             store 246.94  to aSong[7,1]
  97.             store   5     to aSong[7,2]
  98.             store 220     to aSong[8,1]
  99.             store   5     to aSong[8,2]
  100.             store 220     to aSong[9,1]
  101.             store   5     to aSong[9,2]
  102.             store 205     to aSong[10,1]
  103.             store   5     to aSong[10,2]
  104.             store 220     to aSong[11,1]
  105.             store  15     to aSong[11,2]
  106.         case nSong = 2  && "touchdown"
  107.             declare aSong[7,2]           && 7 notes, 2 parts each
  108.             store 523.5   to aSong[1,1]  && pitch
  109.             store   2     to aSong[1,2]  && duration
  110.             store 587.33  to aSong[2,1]
  111.             store   2     to aSong[2,2]
  112.             store 659.29  to aSong[3,1]
  113.             store   2     to aSong[3,2]
  114.             store 783.99  to aSong[4,1]
  115.             store   7     to aSong[4,2]
  116.             store 659.29  to aSong[5,1]
  117.             store   2     to aSong[5,2]
  118.             store 783.99  to aSong[6,1]
  119.             store  10     to aSong[6,2]
  120.         otherwise                       && not song 1 or 2, return nothing
  121.             return chr(7)
  122.     endcase
  123.     
  124.     *-- playback
  125.     nCounter = 1
  126.     do while type("aSong[nCounter,1]") = "N"
  127.         set bell to aSong[nCounter,1],aSong[nCounter,2]
  128.         ?? chr(7) at col()
  129.         nCounter = nCounter + 1
  130.     enddo
  131.     set bell to  && return value to original
  132.  
  133. RETURN ""
  134. *-- EoF: PlayIt()
  135.  
  136. PROCEDURE PageEst
  137. *-------------------------------------------------------------------------------
  138. *-- Programmer..: Rachel Holmen (RAEHOLMEN)
  139. *-- Date........: 02/04/1992
  140. *-- Notes.......: This procedure estimates the number of pages needed for an 
  141. *--                output list. 
  142. *-- Written for.: dBASE IV, 1.1
  143. *-- Rev. History: 01/15/1992 - original procedure.
  144. *--               02/04/1992 - Ken Mayer - overhaul to allow the sending of
  145. *--               parameters for fields, rather than hard coding. Attempted to
  146. *--               make this a "black box" procedure.
  147. *-- Calls.......: CENTER               Procedure in PROC.PRG
  148. *--               SHADOW               Procedure in PROC.PRG
  149. *-- Called by...: Any
  150. *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords>
  151. *-- Example.....: Use printers
  152. *--               Do PageEst with 0,"Printer for 'Hew' $ Brand",55
  153. *-- Returns.....: None
  154. *-- Parameters..: nCount   = record count for records to be printed ...
  155. *--                          if sent as "0", system will do a RECCOUNT() for you
  156. *--               cReport  = name of report, with any filters ... (FOR ...)
  157. *--               nRecords = number of records per page the report will handle.
  158. *--                          if sent as "0", system will assume 60 ...
  159. *-------------------------------------------------------------------------------
  160.  
  161.     parameters nCount,cReport,nRecords
  162.     private cReport2,nPos,nPage,cPage,cChoice,cCursor
  163.     
  164.     cReport2 = upper(cReport)
  165.     
  166.     *-- make sure we have a number of records to work with ...
  167.     if nCount = 0
  168.         if at("FOR",cReport2) > 0     && if a filter, extract the filter
  169.             npos = at("FOR",cReport2)  && so we can count records that match
  170.             cFilter = substr(cReport,Pos+3,len(cReport)-(npos-1))
  171.             count to nCount for &cFilter
  172.         else
  173.             nCount = reccount()
  174.         endif
  175.     endif
  176.     
  177.     if nRecords = 0
  178.         nRecords = 60
  179.     endif
  180.     
  181.     *-- calculate the number of pages for the report ...
  182.     store int(nCount/nRecords) to nPage
  183.     if mod(nCount,nRecords) > 45
  184.         store nPage+1 to nPage
  185.     else
  186.        store (nCount/nRecords) to nPage
  187.     endif
  188.     if nCount>0 .and. nCount < nRecords
  189.        store 1 to nPage
  190.     endif
  191.     
  192.     *-- deal with displaying info, and printing the report ...
  193.     save screen to sPrinter
  194.     activate screen            && in case there are other windows on screen ...
  195.     define window wPrinter from 8,15 to 15,65 double color rg+/gb,w/n,rg+/gb
  196.     do shadow with 8,15,15,65
  197.     activate window wPrinter
  198.     
  199.     *-- figure out how much to tell the user ...
  200.     if mod(nCount,nRecords) > 19 .and. mod(nCount,nRecords) < 46
  201.        store ltrim(str(nPage))+" and a half pages.)" to cPage
  202.     else
  203.        store ltrim(str(nPage))+" pages.)" to cPage
  204.     endif
  205.     
  206.     if nPage = 1
  207.        store "one page.)" to cPage
  208.     endif
  209.     
  210.     *-- display info ...
  211.     do center with 1,50,"",;
  212.         "There are "+ltrim(str(nCount))+" records."
  213.     do center with 2,50,"","(That's approximately "+cPage
  214.     
  215.     *-- ask if they want to generate the report?
  216.     store space(1) to cChoice
  217.     @4,8 say "Do you want to print the list? " get cChoice picture "!" ;
  218.         valid required cChoice $ "YN";
  219.         error chr(7)+"Enter 'Y' or 'N'!"
  220.     read
  221.     
  222.     *-- if yes, do it ...
  223.     if cChoice = "Y"
  224.         clear   && just this window ...
  225.         do center with 2,50,"","Align paper in your printer."
  226.         do center with 3,50,"","Press any key to continue ..."
  227.         x=inkey(0)
  228.         clear
  229.         do center with 2,50,"","... Printing ... do not disturb ..."
  230.         cCursor = set("CURSOR")
  231.         set cursor off
  232.         set console off
  233.         report form &cReport to print
  234.         set console on
  235.         set cursor &cCursor
  236.     endif
  237.     
  238.     *-- cleanup
  239.     deactivate window wPrinter
  240.     release window wPrinter
  241.     restore screen from sPrinter
  242.     release screen sPrinter
  243.  
  244. RETURN
  245. *-- EoP: PageEst
  246.  
  247. FUNCTION Permutes
  248. *-------------------------------------------------------------------------------
  249. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  250. *-- Date........: 03/01/1992
  251. *-- Notes.......: Permutations of nNum items taken Nhowmany at a time
  252. *--               That is, the number of possible arrangements, as
  253. *--               the different ways a president, V.P. and sec'y may
  254. *--               be chosen from a club of 10 members
  255. *-- Written for.: dBASE IV, 1.1
  256. *-- Rev. History: None
  257. *-- Calls.......: None
  258. *-- Called by...: Any
  259. *-- Usage.......: Permutes(<nNum>,<nHowMany>)
  260. *-- Example.....: ?Permutes(10,3)
  261. *-- Returns.....: Numeric
  262. *-- Parameters..: nNum     = number of items in the entire set
  263. *--               nHowMany = number to be used at once
  264. *-------------------------------------------------------------------------------
  265.  
  266.     parameters nNum, nHowmany
  267.     private nResult, nCounter
  268.     store 1 to nResult, nCounter
  269.     do while nCounter <= nHowmany
  270.       nResult = nResult * ( nNum + 1 - nCounter )
  271.       nCounter = nCounter + 1
  272.     enddo
  273.     
  274. RETURN nResult
  275. *-- EoF: Permutes()
  276.  
  277. FUNCTION Combos
  278. *-------------------------------------------------------------------------------
  279. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  280. *-- Date........: 03/01/1992
  281. *-- Notes.......: Combinations, similar to Permutations
  282. *--               Combinations treat "1, 3" as the same as
  283. *--               "3, 1", unlike permutations.  This gives the
  284. *--               games needed for a round robin and helps with
  285. *--               figuring odds of most state lotteries.
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: None
  288. *-- Calls.......: None
  289. *-- Called by...: Any
  290. *-- Usage.......: Combos(<nNum>,<nHowMany>)
  291. *-- Example.....: ?Combos(10,2)
  292. *-- Returns.....: Numeric
  293. *-- Parameters..: nNum     = number of items in the entire set
  294. *--               nHowMany = number to be used at once
  295. *-------------------------------------------------------------------------------
  296.  
  297.     parameters nNum, nHowmany
  298.     private nResult, nCounter
  299.     store 1 to nResult, nCounter
  300.     do while nCounter <= nHowmany
  301.       nResult = nResult * ( nNum + 1 - nCounter ) / nCounter
  302.       nCounter = nCounter + 1
  303.     enddo
  304.     
  305. RETURN nResult
  306. *-- Combos()
  307.                                                           
  308. FUNCTION BinLoad
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  311. *-- Date........: 03/01/1992
  312. *-- Notes.......: Function to manage .bin files
  313. *--               A call to this function results in the following actions:
  314. *--          
  315. *--               If the name of a binary module alone is given as the argument,
  316. *--               the module is loaded if necessary, and .T. is returned.
  317. *--               If the file cannot be found, returns .F.
  318. *--               An error occurring during the load will cause a dBASE error.
  319. *--
  320. *--               If the argument "" is given, RELEASES all loaded modules and
  321. *--               returns .T.
  322. *--
  323. *--               If the argument contains the name of a loaded binary file
  324. *--               and "/R", RELEASEs that file only and returns .T.  If the
  325. *--               file is not listed in "gc_bins_in", returns .F.
  326. *--
  327. *--               This function uses the public variable "gc_bins_in".  It
  328. *--               keeps track of the modules loaded by changing the contents
  329. *--               of that variable.  If modules are loaded or released without
  330. *--               the use of this function, the variable will contain an
  331. *--               inaccurate list of the modules loaded and problems will
  332. *--               almost surely occur if this function is used later.
  333. *--
  334. *--               If more than 16 binary modules are requested over time through
  335. *--               this function, the one that was named least recently in a call
  336. *--               to load it by this function is released to make room for the
  337. *--               new one.  This will not necessarily be the module last used,
  338. *--               unless care is taken to use this function to "reload" the
  339. *--               .bin before each call.
  340. *--
  341. *--               Suggested syntax, to call the binary routine "Smedley.bin" 
  342. *--               which takes and returns two arguments:
  343. *-- 
  344. *--               IF binload( "Smedley" )
  345. *--                 CALL Smedley WITH Arg1, Arg2
  346. *--               ELSE
  347. *--                 ? "binary file not available"
  348. *--               ENDIF
  349. *-- Written for.: dBASE IV, 1.1
  350. *-- Rev. History: None
  351. *-- Calls.......: ATCOUNT()            Function in MISC.PRG
  352. *-- Called by...: Any
  353. *-- Usage.......: BinLoad(<cBinName>)
  354. *-- Example.....: ?BinLoad("Smedley")
  355. *-- Returns.....: Logical (.T. if successful )
  356. *-- Parameters..: cBinName = name of bin file to load ...
  357. *-------------------------------------------------------------------------------
  358.  
  359.     parameters cBinname
  360.    private cBin, nPlace, nTemp, lResult
  361.     cBin = ltrim( trim( upper( cBinname ) ) )
  362.     if type( "gc_bins_in" ) = "U"
  363.        public gc_bins_in
  364.        gc_bins_in = ""
  365.     endif
  366.    lResult = .T.
  367.    do case
  368.        case "" = cBin
  369.            do while "" # gc_bins_in
  370.               nPlace = at( "*", gc_bins_in )
  371.               cBin = left( gc_bins_in, nPlace - 1 )
  372.               gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  373.               release module &cBin
  374.            enddo
  375.            release gc_bins_in
  376.        case "/R" $ cBinname
  377.            cBin = trim( left( cBin, at( cBin, "/" ) - 1 ) )
  378.           if "." $ cBin
  379.              cBin = left( cBin, at( ".", cBin ) - 1 )
  380.           endif
  381.           nPlace = at( cBin, gc_bins_in )
  382.            if nPlace = 0
  383.              lResult = .F.
  384.           else
  385.              gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  386.              release module &cBin
  387.           endif
  388.        otherwise
  389.           if "." $ cBin
  390.              cBin = left( cBin, at( ".", cBin ) - 1 )
  391.           endif
  392.           if .not. file( cBin )
  393.              lResult = .F.
  394.           else
  395.              if atcount( "*", gc_bins_in ) > 15
  396.                 nPlace = at( "*", gc_bins_in )
  397.                 cTemp = left( gc_bins_in, nPlace - 1 )
  398.                 release module &cTemp
  399.                 gc_bins_in = substr( gc_bins_in, nPlace + 1)
  400.              endif
  401.              load &cBin
  402.              nPlace = at( cBin, gc_bins_in )
  403.              if Place > 0
  404.                 gc_bins_in = stuff( gc_bins_in, nPlace, len( cBin ) + 1, "" )
  405.              endif
  406.              gc_bins_in = gc_bins_in + cBin + "*"
  407.           endif
  408.    endcase
  409.  
  410. RETURN lResult
  411. *-- EoF: BinLoad()
  412.  
  413. FUNCTION DialUp
  414. *-----------------------------------------------------------------------
  415. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  416. *-- Date........: 06/17/1992
  417. *-- Notes.......: Dial the supplied telephone number.  Returns .F. for error.
  418. *--               This is not a full communications routine.  It is designed
  419. *--               to be used to place voice telephone calls, with the user
  420. *--               picking up the handset after using this function to dial.
  421. *--
  422. *--               This will work only with a modem using the standard Hayes
  423. *--               commands, and only if the port has already been set to the
  424. *--               desired baud rate, etc., by the DOS MODE command or 
  425. *--               otherwise.  If the port and dialing method are not constant
  426. *--               for the application, rewrite the function to accept them as
  427. *--               additional parameters.
  428. *--
  429. *-- Written for.: dBASE IV, 1.1, 1.5
  430. *-- Rev. History: 03/01/1992 - original function.
  431. *--               04/01/1992 - Jay Parsons - modified for Version 1.5.
  432. *--               04/03/1992 - Jay Parsons - ferror() call added.
  433. *--               06/17/1992 - Jay Parsons - 1.1 version changed to use
  434. *--                              SET PRINTER TO Device rather than .bin.
  435. *-- Calls       : Strpbrk()            Function in MISC.PRG
  436. *-- Called by...: Any
  437. *-- Usage.......: DialUp(<cPhoneNo>)
  438. *-- Example.....: x = DialUp( "555-1212" )
  439. *-- Returns.....: Logical (connect made or not)
  440. *-- Parameters..: cPhoneNo = Phone number to dial ...
  441. *-- Side effects: When used for versions before 1.1, sets the printer to
  442. *--             : a COM port and does not reset it.
  443. *-----------------------------------------------------------------------
  444.  
  445.    parameters cPhoneNo
  446.    private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,;
  447.               cString, lResult
  448.    cPort = "Com2"          && specify Com1 or Com2 as required 
  449.    cDialtype = "Tone"      && specify Tone or Pulse ( rotary ) dialing
  450.    cNumber = cPhoneno
  451.    if type( "cPhoneno" ) $ "NF"
  452.       cNumber = ltrim( str( cPhoneno ) )
  453.    else
  454.       do while .t.
  455.          xTemp = Strpbrk( cNumber, " ()-" )
  456.          if xTemp = 0
  457.             exit
  458.          endif
  459.          cNumber = stuff( cNumber, xTemp, 1, "" )
  460.       enddo
  461.    endif
  462.    cString = "ATD" + upper( left( cDialtype, 1 ) ) + cNumber + chr(13 )
  463.    if val( substr( version(), 9, 5 ) ) < 1.5
  464.       SET PRINTER TO &cPort
  465.       ??? Cstring
  466.       lResult = .T.
  467.    else
  468.       nHandle = fopen( cPort, "w" )
  469.       if ferror() # 0
  470.          RETURN .F.
  471.       endif
  472.       lResult = ( fwrite( nHandle, cString ) = len( cString ))
  473.       xTemp = fclose( nHandle )
  474.    endif
  475.  
  476. RETURN lResult
  477. *-- EoF: Dialup()
  478.  
  479. FUNCTION CurrPort
  480. *-------------------------------------------------------------------------------
  481. *-- Programmer..: David P. Brown (RHEEM)
  482. *-- Date........: 03/22/1992
  483. *-- Notes.......: This procedure gets the current SET PRINTER TO information.
  484. *--               Will return a port or a filename if set to a file. This also
  485. *--               requires a DBF file called CURRPRT.DBF, with an MDX tag
  486. *--               set on the only field CURRPRT, which is a character field
  487. *--               of 80 characters.
  488. *--
  489. *--               Structure for database: CURRPRT.DBF
  490. *--               Number of data records:       0
  491. *--               Date of last update   : 03/22/92
  492. *--               Field  Field Name  Type       Width    Dec    Index
  493. *--                   1  CURRPRT     Character     80               Y
  494. *--               ** Total **                      81
  495. *--
  496. *-- Written for.: dBASE IV, 1.1
  497. *-- Rev. History: 03/18/1992 - original function.
  498. *--               03/18/1992 -- Ken Mayer (CIS: 71333,1030) to clean it up a bit, and
  499. *--               make it a function (not requiring the public memvar that
  500. *--               was originally required).
  501. *--               03/21/1992 -- David P. Brown (RHEEM) found bug while
  502. *--               selecting a previous work area (stored on cDBF).  Changed
  503. *--               'select cDBF' to 'select (cDBF)'.
  504. *--               03/22/1992 -- David P. Brown (RHEEM) final revision.  Added
  505. *--               check for no available work areas.  If none is available
  506. *--               then the program returns a null.
  507. *-- Calls.......: None
  508. *-- Called by...: Any
  509. *-- Usage.......: CurrPort()
  510. *-- Example.....: ? CurrPort()
  511. *-- Returns.....: the current port, as a character value
  512. *--               Port:   LPTx:, COMx:, PRN:
  513. *--               File:   Filename (with or without drive and path, depends
  514. *--                       on how the user entered it in the SET command)
  515. *--               Other:  Null (no work area available)
  516. *-- Parameters..: None
  517. *-------------------------------------------------------------------------------
  518.  
  519.    private cSafety, cConsole, cDBF, cPort
  520.  
  521.    *-- Check for available work area (safety check)
  522.    if select() = 0
  523.       return ""
  524.    endif
  525.    *-- Setup
  526.    cSafety = set("SAFETY")
  527.    set safety off
  528.    *-- so user can't see what's going on
  529.    cConsole = set("CONSOLE")
  530.    set console off
  531.    
  532.    if file("CURRPRT$.OUT")  && if this file exists
  533.       erase CURRPRT$.OUT    &&   delete it, so we can write on it
  534.    endif
  535.    
  536.    cDBF = alias()           && get current work area, so we can return ...
  537.    
  538.    *-- Get current printer
  539.    *-- note that we are not using 'Set Printer to file ...' due to the
  540.    *-- fact that this will change the info that the 'LIST STAT' command
  541.    *-- issues ...
  542.    set alternate to currprt$.out  && direct screen input to file
  543.    set alternate on
  544.    list status                    && returns environment information
  545.    set alternate off              && turn off 'capture'
  546.    close alternate                && close file 'currprt$.out'
  547.  
  548.    select select()                && grab next available work area ...
  549.    
  550.    use currprt order currprt excl && open database called CURRPRT
  551.    zap                            && clean out old copy of this file
  552.    
  553.    append from currprt$.out type sdf
  554.                                   && import the data for manipulation
  555.    
  556.    seek "Print"
  557.    *-- This is setup to do an indexed search, since the printer information
  558.    *-- will not always be on the same line. If it were, we could issue a
  559.    *-- 'GO <n>' command, which would speed up the routine. Somewhere on
  560.    *-- line 8 to 12 (or record) is 'Print destination: <port/file>'. The
  561.    *-- seek looks for the first word. The command below trims out the
  562.    *-- first part of the line, and extra spaces as well. This will
  563.    *-- return the information after the colon.
  564.    cPort = upper(trim(right(currprt,60))) && always in upper case
  565.    
  566.    *-- clean up
  567.    use
  568.    
  569.    if len(trim(cDBF)) > 0
  570.       select (cDBF)
  571.    else
  572.       select 1
  573.    endif
  574.    
  575.    *-- erase this file
  576.    erase currprt$.out 
  577.    
  578.    *-- return safety and console to previous states ...
  579.    set safety &cSafety
  580.    set console &cConsole
  581.    
  582. RETURN cPort
  583. *-- EoF: CurrPort()
  584.  
  585. FUNCTION FileLock
  586. *-------------------------------------------------------------------------------
  587. *-- Programmer..: Miriam Liskin
  588. *-- Date........: 04/27/1992
  589. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  590. *--               This routine modified by Ken Mayer to handle slightly
  591. *--               fancier processing ...
  592. *-- Written for.: dBASE IV, 1.1
  593. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  594. *--               and such.
  595. *-- Calls.......: CENTER               Procedure in PROC.PRG
  596. *--               SHADOW               Procedure in PROC.PRG
  597. *-- Called by...: Any
  598. *-- Usage.......: FileLock("<cColor>") 
  599. *-- Example.....: if FileLock("&cl_Wind1")
  600. *--                  *-- pack/reindex/whatever you need to do to database
  601. *--               else
  602. *--                  *-- do whatever processing necessary if file not
  603. *--                  *-- available for locking at this time
  604. *--               endif
  605. *-- Returns.....: Logical (.t./.f.)
  606. *-- Parameters..: cColor = Color combination for window ...
  607. *-------------------------------------------------------------------------------
  608.  
  609.     parameters cColor
  610.     private nCount,lLock,x,cCurNorm,cCurBox,cTempCol
  611.     
  612.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  613.     on error ??
  614.     
  615.     *-- deal with screen stuff ...
  616.     *-- get it started ...
  617.     nCount = 1   && start at 1
  618.     lLock = .t.  && assume true
  619.     
  620.     *-- try 100 times
  621.     do while nCount <= 100 .and. .not. flock() .and. inkey() = 0
  622.         nCount = nCount + 1
  623.     enddo
  624.     
  625.     *-- if we can't lock the file, let the user know ...
  626.     if .not. flock()
  627.         lLock = .f.
  628.         save screen to sLock
  629.         *-- save colors
  630.         cCurNorm = colorof("NORMAL")
  631.         cCurBox  = colorof("BOX")
  632.         *-- set new colors
  633.         cTempCol = colorbrk(cColor,1)
  634.         set color of normal to &cTempCol
  635.         cTempCol = colorbrk(cColor,3)
  636.         set color of box to &cTempCol
  637.         *-- define window, display message
  638.         activate screen
  639.         define window wLock from 10,15 to 18,65 double
  640.         do shadow with 10,15,18,65
  641.         activate window sLock
  642.         do center with 1,50,"","The file cannot be locked at this time"
  643.         do center with 2,50,"","Please try again."
  644.         x = inkey(0)
  645.         *-- cleanup
  646.         deactivate window wLock
  647.         release window wLock
  648.         restore screen from sLock
  649.         release screen sLock
  650.         *-- reset colors
  651.         set color of normal to &cCurNorm
  652.         set color of box    to &cCurBox
  653.     endif
  654.     
  655.     *-- clean up screen, etc.
  656.     on error
  657.     
  658. RETURN lLock
  659. *-- EoF: FileLock()
  660.  
  661. FUNCTION RecLock
  662. *-------------------------------------------------------------------------------
  663. *-- Programmer..: Miriam Liskin
  664. *-- Date........: 04/27/1992
  665. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  666. *--               This function attempts to lock current record in active
  667. *--               database. 
  668. *-- Written for.: dBASE IV, 1.1
  669. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  670. *--               and such.
  671. *-- Calls.......: CENTER               Procedure in PROC.PRG
  672. *--               SHADOW               Procedure in PROC.PRG
  673. *-- Called by...: Any
  674. *-- Usage.......: RecLock("<cColor>") 
  675. *-- Example.....: if RecLock("&cl_Wind1")
  676. *--                  *-- process record
  677. *--               else
  678. *--                  *-- return to menu, or whatever processing your routine
  679. *--                  *-- does at this point
  680. *--               endif
  681. *-- Returns.....: Logical (.t./.f.)
  682. *-- Parameters..: cColor = Color combination for window ...
  683. *-------------------------------------------------------------------------------
  684.  
  685.     parameters cColor
  686.     private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol
  687.     
  688.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  689.     on error ??
  690.     
  691.     *-- deal with screen
  692.     *-- start trying -- we will give the user the option to exit -- each time
  693.     *-- they unsuccessfully lock the record.
  694.     lLock = .t.   && assume true
  695.     do while .t.  && main loop
  696.         nCount = 1 && initialize each time we try ...
  697.         
  698.         *-- effectively a time-delay loop ...
  699.         do while nCount <= 100 .and. .not. rLock() .and. inkey() = 0
  700.             nCount = nCount + 1
  701.         enddo
  702.         
  703.         *-- if we CAN lock it, we're done, get outta here ...
  704.         if rlock()
  705.             lLock = .t.
  706.             exit
  707.         
  708.         else
  709.         
  710.             *-- otherwise, let the user know we couldn't do it, and ask if
  711.             *-- they want to try again ...
  712.             save screen to sLock
  713.             *-- save colors
  714.             cCurNorm = colorof("NORMAL")
  715.             cCurBox  = colorof("BOX")
  716.             *-- set new colors
  717.             cTempCol = colorbrk(cColor,1)
  718.             set color of normal to &cTempCol
  719.             cTempCol = colorbrk(cColor,3)
  720.             set color of box to &cTempCol
  721.             *-- define window ...
  722.             activate screen
  723.             define window wLock from 10,15 to 18,65 double
  724.             do shadow with 10,15,18,65
  725.             activate window wLock
  726.             lLock = .f.
  727.             cRetry = 'N'
  728.             @1,3 say "This record is being updated at another"
  729.             @2,3 say "workstation. You can try again now,"
  730.             @3,3 say "to access the record, or return to it"
  731.             @4,3 say "later."
  732.             @6,3 say "Do you want to try again now? " get cRetry;
  733.                 picture "!";
  734.                 valid required cRetry $ "YN";
  735.                 error chr(7)+"Enter 'Y' or 'N'"
  736.             read
  737.             *-- cleanup
  738.             deactivate window wLock
  739.             release window wLock
  740.             restore screen from sLock
  741.             release screen sLock
  742.             *-- reset colors
  743.             set color of normal to &cCurNorm
  744.             set color of box    to &cCurBox
  745.             
  746.             if cRetry = "N"
  747.                 exit
  748.             endif  && cRetry = "N"
  749.             
  750.         endif  && rLock()
  751.         
  752.     enddo  && end of main loop
  753.     
  754.     *-- cleanup
  755.     on error
  756.  
  757. RETURN lLock
  758. *-- EoF: RecLock()
  759.  
  760. FUNCTION UserId
  761. *-------------------------------------------------------------------------------
  762. *-- Programmer..: Angus Scott-Fleming (ANGUSSF)
  763. *-- Date........: 04/20/1992
  764. *-- Notes.......: Returns log-in USER ID regardless of Network Type
  765. *--               ***********************************************************
  766. *--               ** IF DBASE IV VERSION IS < 1.5 THIS REQUIRES USERID.BIN **
  767. *--               ***********************************************************
  768. *-- Written for.: dBASE IV v1.5, will work in 1.1, if you use EMPTY()
  769. *-- Rev. History: 10/27/1992 -- Ken Mayer cleaned up a tad ...
  770. *-- Calls.......: None if version 1.5, EMPTY() if version 1.1
  771. *-- Called by...: Any
  772. *-- Usage.......: UserID()
  773. *-- Example.....: ? UserID()
  774. *-- Returns.....: Character String (up to 8 characters)
  775. *-- Parameters..: None
  776. *-------------------------------------------------------------------------------
  777.  
  778.     private cTemp
  779.     if network()
  780.         if .not. isblank(getenv("USERID"))
  781.             *-- if you're working on a Lantastic net, USERID will lock the
  782.             *-- system up. Use a DOS environment variable USERID instead.
  783.             *-- This also works as a temporary override for testing access levels.
  784.             cTemp = left(getenv("USERID"),8)
  785.         else
  786.             if val(right(version(),3)) => 1.5   && version 1.5 of dBASE IV
  787.                 cTemp = id()
  788.             else
  789.                 cTemp = space(48)
  790.                 if file("USERID.BIN")
  791.                     load userid
  792.                     call userid with cTemp
  793.                     release module userid
  794.                 endif && file("USERID.BIN")
  795.             endif && val(right...)
  796.         endif && .not. isblank(getenv ...
  797.     else
  798.         cTemp = ""
  799.     endif  && network()
  800.  
  801. RETURN left(cTemp,8)  && which MIGHT be empty ...
  802. *-- EoF: UserID
  803.  
  804. PROCEDURE DosShell
  805. *-------------------------------------------------------------------------------
  806. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  807. *-- Date........: 06-10-1992
  808. *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell
  809. *-- Written for.: dBASE IV v1.5
  810. *-- Rev. History: none
  811. *-- Calls.......: None
  812. *-- Called by...: Any
  813. *-- Usage.......: do DosShell with <cAppName>
  814. *-- Example.....: do DosShell with "MyApp"
  815. *-- Parameters..: cAppName - the name of the application
  816. *-------------------------------------------------------------------------------
  817.  
  818.     parameter cAppName
  819.      private cDir, lCursOff, cBatFile, nFH, nResult
  820.     cAppName = iif(pcount() = 0, "the application", cAppName)
  821.     private all
  822.     cDir = set("directory")
  823.     lCursOff = ( set("cursor") = "OFF" )
  824.     cBatFile = tempname("bat") + ".bat"
  825.     nFH = fcreate(cBatFile)
  826.     if nFH > 0
  827.         nBytes = fputs(nFH,"echo off")
  828.         nBytes = fputs(nFH,"cls")
  829.         nBytes = fputs(nFH,"echo " + chr(255))  && echo a blank line
  830.         nBytes = fputs(nFH,"echo NOTE: Enter EXIT to resume " + cAppName + ".")
  831.         nBytes = fwrite(nFH,getenv("comspec"))
  832.         null = fclose(nFH)
  833.         set cursor on
  834.         nResult = run(.f., cBatFile, .t.)
  835.         if nResult # 0
  836.             run &cBatFile
  837.         endif
  838.         erase (cBatFile)
  839.     else
  840.         cComSpec = getenv("comspec")
  841.         set cursor on
  842.         run &cComSpec.
  843.     endif
  844.     if lCursOff
  845.         set cursor off
  846.     endif
  847.     set directory to &cDir
  848.  
  849. RETURN
  850. *-- EoP: DosShell
  851.  
  852. FUNCTION IsDisk
  853. *-------------------------------------------------------------------------------
  854. *-- Programmer...: Ken Mayer (CIS: 71333,1030)
  855. *-- Date.........: 07/13/1992
  856. *-- Notes........: This routine is useful to check a drive for a valid disk in
  857. *--                in it (Valid means it is in the drive, with the door closed,
  858. *--                and is formatted ...). 
  859. *--                ***********************
  860. *--                ** REQUIRES DISK.BIN **
  861. *--                ***********************
  862. *-- Written for.: dBASE IV, 1.5
  863. *-- Rev. History: None
  864. *-- Called by...: None
  865. *-- Calls.......: CENTER               Procedure in PROC.PRG
  866. *--               SHADOW               Procedure in PROC.PRG
  867. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  868. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  869. *-- Returns.....: Logical
  870. *-- Parameters..: cDrive   = drive name -- single letter, no colon (i.e., "A")
  871. *--               cMessCol = color for message bonX
  872. *--               cErrCol  = color for error message
  873. *-------------------------------------------------------------------------------
  874.  
  875.     parameters cDrive, cMessCol, cErrCol
  876.  
  877.     private nX, cDrive2
  878.     
  879.     *-- deal with message window
  880.     save screen to sDisk
  881.     activate screen
  882.     define window wDisk from 9,15 to 12,65 double color &cMessCol,,&cMessCol
  883.     do shadow with 9,15,12,65
  884.     activate window wDisk
  885.     *-- display message ...
  886.     do center with 0,50,"&cMessCol",;
  887.         "Place disk in drive "+cDrive+": and close drive door."
  888.     do center with 1,50,"&cMessCol",;
  889.         "Press any key when ready ..."
  890.     set cursor off
  891.     nX=inkey(0)
  892.     set cursor on
  893.     deactivate window wDisk
  894.     restore screen from sDisk
  895.  
  896.     *-- check for a valid drive. This uses the BIN file: DISK.BIN to do so.
  897.     load disk                 && load the BIN file
  898.     cDrive2 = cDrive          && save the current setting in case there's a prob.
  899.     call disk with cDrive2    && check to see if it's valid
  900.     activate screen
  901.     define window wDisk from 7,10 to 14,70 double color &cErrCol,,&cErrCol
  902.     do while cDrive2 = 'X'    && perform loop if value of cDrive2 is 'X' (error)
  903.         do shadow with 7,10,14,70
  904.         activate window wDisk
  905.         do center with 0,60,"&cErrCol",;
  906.             "** DRIVE ERROR **"
  907.         do center with 2,60,"&cErrCol",;
  908.             "Check to make sure a valid (formatted) disk is in drive,"
  909.         do center with 3,60,"&cErrCol",;
  910.             "and that the drive door is closed properly."
  911.         do center with 5,60,"&cErrCol",;
  912.             "Press <Esc> to exit, any other key to continue ..."
  913.         set cursor off
  914.         nX=inkey(0)
  915.         set cursor on
  916.         deactivate window wDisk
  917.         restore screen from sDisk
  918.         if nX = 27                 && user pressed <Esc>
  919.             release module disk
  920.             release window wDisk
  921.             release screen sDisk
  922.             RETURN .F.
  923.         endif
  924.         cDrive2 = cDrive          && reset cDrive2 from original
  925.         call disk with cDrive2    && check for validity again ...
  926.     enddo
  927.  
  928.     *-- cleanup
  929.     release module Disk          && remove module from RAM so we can continue
  930.     restore screen from sDisk
  931.     release screen sDisk
  932.     release window wDisk
  933.  
  934. RETURN .t.
  935. *-- EoF: IsDisk()
  936.  
  937. *-------------------------------------------------------------------------------
  938. *-- The following are here as a courtesy ...
  939. *-------------------------------------------------------------------------------
  940.  
  941. FUNCTION AtCount
  942. *-------------------------------------------------------------------------------
  943. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  944. *-- Date........: 03/01/92
  945. *-- Notes.......: returns the number of times FindString is found in Bigstring
  946. *-- Written for.: dBASE IV
  947. *-- Rev. History: None
  948. *-- Calls.......: None
  949. *-- Called by...: Any
  950. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  951. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  952. *-- Returns.....: Numeric value
  953. *-- Parameters..: cFindStr = string to find in cBigStr
  954. *--               cBigStr  = string to look in
  955. *-------------------------------------------------------------------------------
  956.  
  957.     parameters cFindstr, cBigstr
  958.     private cTarget, nCount
  959.     
  960.     cTarget = cBigstr
  961.     nCount = 0
  962.     
  963.     do while .t.
  964.         if at( cFindStr,cTarget ) > 0
  965.             nCount = nCount + 1
  966.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  967.         else
  968.          exit
  969.         endif
  970.     enddo
  971.     
  972. RETURN nCount
  973. *-- EoF: AtCount()
  974.     
  975. FUNCTION Dec2Hex
  976. *-------------------------------------------------------------------------------
  977. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  978. *-- Date........: 03/01/1992
  979. *-- Notes.......: Converts an integral number ( in decimal notation)
  980. *--               to a hexadecimal string
  981. *-- Written for.: dBASE IV, 1.1
  982. *-- Rev. History: None
  983. *-- Calls.......: None
  984. *-- Called by...: Any
  985. *-- Usage.......: Dec2Hex(<nDecimal>)
  986. *-- Example.....: ? Dec2Hex( 118 )
  987. *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example )
  988. *-- Parameters..: nDecimal = number to convert
  989. *-------------------------------------------------------------------------------
  990.     
  991.     parameters nDecimal
  992.     private nD, cH
  993.     nD = int( nDecimal )
  994.     cH= ""
  995.     do while nD > 0
  996.       cH = substr( "0123456789ABCDEF", mod( nD, 16 ) + 1 , 1 ) + cH
  997.       nD = int( nD / 16 )
  998.     enddo
  999.     
  1000. RETURN iif( "" = cH, "0", cH )
  1001. *-- Eof: Dec2Hex()
  1002.  
  1003. FUNCTION StrPBrk
  1004. *-------------------------------------------------------------------------------
  1005. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1006. *-- Date........: 03/01/92
  1007. *-- Notes.......: Search string for first occurrence of any of the
  1008. *--               characters in charset.  Returns its position as
  1009. *--               with at().  Contrary to ANSI.C definition, returns
  1010. *--               0 if none of characters is found.
  1011. *-- Written for.: dBASE IV
  1012. *-- Rev. History: None
  1013. *-- Calls.......: None
  1014. *-- Called by...: Any
  1015. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  1016. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  1017. *-- Returns.....: Numeric value
  1018. *-- Parameters..: cCharSet = characters to look for in cBigStr
  1019. *--               cBigStr  = string to look in
  1020. *-------------------------------------------------------------------------------
  1021.  
  1022.     parameters cCharset, cBigstring
  1023.     private nPos, nLooklen
  1024.     nPos = 0
  1025.     nLooklen = len( cBigstring )
  1026.     do while nPos < nLooklen
  1027.       nPos = nPos + 1
  1028.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  1029.          exit
  1030.        endif
  1031.     enddo
  1032.     
  1033. RETURN iif(nPos=nLookLen,0,nPos)
  1034. *-- EoF: StrPBrk()
  1035.  
  1036. PROCEDURE BlankIt
  1037. *-------------------------------------------------------------------------------
  1038. *-- Programmer..: Bill Garrison (BILLG), Roger Breckenridge 
  1039. *-- Date........: 01/08/1993
  1040. *-- Notes.......: Screen Saver from within dbase - uploaded to Public Domain
  1041. *-- Written for.: dBase IV 1.5  (probably work with 1.1 though)
  1042. *-- Rev. History: Original clock prg was from Michael Irwin, who I believe
  1043. *--             : expanded on from source unknown.
  1044. *--             : 10/29/1992: Modified original program received at
  1045. *--             :             Ashton-Tate Seminar a year or so ago.
  1046. *--             :             Fine tuned it and added moving window feature.
  1047. *--             : 11/02/1992: Modified -- Ken Mayer -- dUFLP and added
  1048. *--             :             Jay's RECOLOR routine, as SET COLOR TO
  1049. *--                           does not reset properly.
  1050. *--               01/08/1992: Fixed ON KEY reset, which was to "Blanker", not
  1051. *--                           "Blankit".
  1052. *-- Calls.......: CLOCKIT              Procedure in MISC.PRG
  1053. *--             : CLOCK                Procedure in MISC.PRG
  1054. *--             : RECOLOR              Procedure in PROC.PRG
  1055. *-- Called by...: Any
  1056. *-- Usage.......: Do BLANKIT
  1057. *-- Example.....: ON KEY LABEL Alt-B DO BlankIt
  1058. *-- Returns.....: None
  1059. *-- Parameters..: None
  1060. *-------------------------------------------------------------------------------
  1061.     
  1062.    on key label alt-B           && turn off key label that called this prg
  1063.    save screen to sBlanker
  1064.    private aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,;
  1065.            clSet2,clSet3,cTalk,cCursor
  1066.     
  1067.     *-- save settings
  1068.    cCursor= set("CURSOR")
  1069.    cTalk  = set("TALK")
  1070.    set cursor off
  1071.    set talk off
  1072.    
  1073.    *-- screen colors
  1074.    clSet2 = set("ATTRIBUTES")
  1075.    clSet3 = left(clset2,at(" ",clset2)-1)
  1076.    set color to N/N,N/N,N/N
  1077.  
  1078.    *-- blank screen
  1079.    lMary=.T.
  1080.    activate screen
  1081.    @0,0 fill to 24,79 color N/N
  1082.    store 0 to nTX,nTY
  1083.  
  1084.    *-- wait for user to do something ...
  1085.    do while lMary
  1086.       do clockit  && display clock
  1087.       nTX=iif(nTX>16,0,nTX+2)
  1088.       nTY=iif(nTY>46,0,nTY+4)
  1089.    enddo
  1090.  
  1091.    *-- reset
  1092.    restore screen from sBlanker
  1093.    release screen sBlanker
  1094.    on key label alt-B do blankit        && reset on key
  1095.    do recolor with clSet2
  1096.    set cursor &cCursor.
  1097.    set talk &cTalk                      && reset talk & cursor to entry
  1098.    release aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,clSet2,;
  1099.            clSet3,cCursor,cTime,nMin1,nMin2,cTalk
  1100.  
  1101. RETURN
  1102. *-- EoP: BlankIt
  1103.  
  1104. PROCEDURE ClockIt 
  1105. *-------------------------------------------------------------------------------
  1106. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1107. *-- Date........: 10/29/1992
  1108. *-- Notes.......: Display clock for BLANKER routine.
  1109. *-- Written for.: dBASE IV, 1.5
  1110. *-- Rev. History: None
  1111. *-- Calls.......: CLOCK                Procedure in MISC.PRG
  1112. *-- Called by...: BLANKIT              Procedure in MISC.PRG
  1113. *-- Usage.......: do clockit
  1114. *-- Example.....: do clockit
  1115. *-- Returns.....: None
  1116. *-- Parameters..: None
  1117. *-------------------------------------------------------------------------------
  1118.  
  1119.    declare aTime[11,3], aTimeAll[3]
  1120.    define window wClock from m->nTX,m->nTY to m->nTX+5,m->nTY+30 ;
  1121.            color W+/N+,,GR+/R
  1122.    activate window wClock
  1123.    do clock
  1124.    nSec8=1
  1125.    do while nSec8<11             && increase/decrease movement frequency here
  1126.       cTime=iif(val(left(time(),2))>12,;
  1127.             str(val(left(time(),2))-12,2)+substr(time(),3,6),time())
  1128.       nHour1=val(left(cTime,1))+1
  1129.       nHour2=val(substr(cTime,2,1))+1
  1130.       nMin1=val(substr(cTime,4,1))+1
  1131.       nMin2=val(substr(cTime,5,1))+1
  1132.       nSec1=val(substr(cTime,7,1))+1
  1133.       nSec2=val(substr(cTime,8,1))+1
  1134.       aTimeAll[1]=aTime[nHour1,1]+" "+aTime[nHour2,1]+aTime[11,1]+;
  1135.                aTime[nMin1,1]+" "+aTime[nMin2,1]+;    
  1136.                aTime[11,1]+aTime[nSec1,1]+" "+aTime[nSec2,1]
  1137.       aTimeAll[2]=aTime[nHour1,2]+" "+aTime[nHour2,2]+aTime[11,2]+;
  1138.                aTime[nMin1,2]+" "+aTime[nMin2,2]+aTime[11,2]+;
  1139.                aTime[nSec1,2]+" "+aTime[nSec2,2]
  1140.       aTimeAll[3]=aTime[nHour1,3]+" "+aTime[nHour2,3]+aTime[11,3]+;
  1141.                aTime[nMin1,3]+" "+aTime[nMin2,3]+aTime[11,3]+;
  1142.                aTime[nSec1,3]+" "+aTime[nSec2,3]
  1143.  
  1144.       *-- display it 
  1145.       @0,21 say  '    '+iif(val(left(time(),2))>12,'P','A')+'.M.'
  1146.       @1,1 say aTimeAll[1]
  1147.       @2,1 say aTimeAll[2]
  1148.       @3,1 say aTimeAll[3]
  1149.  
  1150.       *-- get input from user?
  1151.       nSec8=nSec8+1
  1152.       nWait=inkey(1)
  1153.       if nWait=27   && wait for <Esc> key
  1154.          lMary=.F.
  1155.          exit
  1156.       endif
  1157.    enddo
  1158.    release window wClock
  1159.  
  1160. RETURN
  1161. *-- EoP: ClockIt
  1162.  
  1163. PROCEDURE Clock
  1164. *-------------------------------------------------------------------------------
  1165. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1166. *-- Date........: 10/29/1992
  1167. *-- Notes.......: Clock Routine (part of BLANKIT) -- defines outlines of clock
  1168. *-- Written for.: dBASE IV, 1.5
  1169. *-- Rev. History: None
  1170. *-- Calls.......: None
  1171. *-- Called by...: CLOCKIT              Procedure in MISC.PRG
  1172. *-- Usage.......: do clock
  1173. *-- Example.....: do clock
  1174. *-- Returns.....: None
  1175. *-- Parameters..: None
  1176. *-------------------------------------------------------------------------------
  1177.  
  1178.    cSpace  = ' '
  1179.    cTop    = CHR(223)  && ▀
  1180.    cBottom = CHR(220)  && ▄
  1181.    cSide   = CHR(219)  && █
  1182.  
  1183.    aTime[1,1]=cSide+cTop+cSide
  1184.    aTime[1,2]=cSide+cSpace+cSide
  1185.    aTime[1,3]=cTop+cTop+cTop
  1186.    aTime[2,1]=cSpace+cSpace+cSide
  1187.    aTime[2,2]=cSpace+cSpace+cSide
  1188.    aTime[2,3]=cSpace+cSpace+cTop
  1189.    aTime[3,1]=cTop+cTop+cSide
  1190.    aTime[3,2]=cSide+cTop+cTop
  1191.    aTime[3,3]=cTop+cTop+cTop
  1192.    aTime[4,1]=cTop+cTop+cSide
  1193.    aTime[4,2]=cSpace+cTop+cSide
  1194.    aTime[4,3]=cTop+cTop+cTop
  1195.    aTime[5,1]=cSide+cSpace+cSide
  1196.    aTime[5,2]=cTop+cTop+cSide
  1197.    aTime[5,3]=cSpace+cSpace+cTop
  1198.    aTime[6,1]=cSide+cTop+cTop
  1199.    aTime[6,2]=cTop+cTop+cSide
  1200.    aTime[6,3]=cTop+cTop+cTop
  1201.    aTime[7,1]=cSide+cTop+cTop
  1202.    aTime[7,2]=cSide+cTop+cSide
  1203.    aTime[7,3]=cTop+cTop+cTop
  1204.    aTime[8,1]=cTop+cTop+cSide
  1205.    aTime[8,2]=cSpace+cSpace+cSide
  1206.    aTime[8,3]=cSpace+cSpace+cTop
  1207.    aTime[9,1]=cSide+cTop+cSide
  1208.    aTime[9,2]=cSide+cTop+cSide
  1209.    aTime[9,3]=cTop+cTop+cTop
  1210.    aTime[10,1]=cSide+cTop+cSide
  1211.    aTime[10,2]=cTop+cTop+cSide
  1212.    aTime[10,3]=cTop+cTop+cTop
  1213.    aTime[11,1]=cSpace+cBottom+cSpace
  1214.    aTime[11,2]=cSpace+cBottom+cSpace
  1215.    aTime[11,3]=cSpace+cSpace+cSpace
  1216.  
  1217. RETURN
  1218. *-- EoP: ClockIt
  1219.  
  1220. FUNCTION AuxMsg
  1221. *-------------------------------------------------------------------------------
  1222. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1223. *--               From ideas by Robert Scola & Sal Ricciardi
  1224. *--               published in PC Magazine, Volume 11, Number 21
  1225. *-- Date........: 11/21/1992
  1226. *-- Notes.......: AuxMsg will output a character string to the DOS AUX
  1227. *--               device. If a dual monitor system is in use and the
  1228. *--               DOS device driver OX.SYS is loaded, the string will
  1229. *--               print on the mono monitor. Parameter 2 determines
  1230. *--               whether the string is preceeded by a linefeed or not.
  1231. *--               *********************************************************
  1232. *--               * OX.SYS must be loaded in CONFIG.SYS file, and machine *
  1233. *--               * Booted with it ...                                    *
  1234. *--               *********************************************************
  1235. *-- Written for.: dBASE IV, 1.5
  1236. *-- Rev. History: None
  1237. *-- Calls.......: None
  1238. *-- Called by...: Any
  1239. *-- Usage.......: AuxMsg( cMsg, lLF )
  1240. *-- Example.....: ? AuxMsg( time(), .t. )
  1241. *--               cJunk = AuxMsg( cMemVar, .f. )
  1242. *--               cJunk = AuxMsg( "Hello! )
  1243. *-- Returns.....: ""
  1244. *-- Parameters..: cMsg = string to output to AUX
  1245. *--               lLF  = .t. or .f., linefeed or not
  1246. *-------------------------------------------------------------------------------
  1247.  
  1248.     parameters cMsg, lLF
  1249.     private nAux, CRLF
  1250.     CRLF = chr(13) + chr(10)
  1251.     nAux = fopen( "aux", "w" )
  1252.     if lLF
  1253.         l = fwrite( nAux, CRLF )
  1254.     endif
  1255.     if type( "cMsg" ) = "C"
  1256.         l = fwrite( nAux, cMsg )
  1257.     endif
  1258.     l = fclose( nAux )
  1259.  
  1260. RETURN ""
  1261. *-- EoF: AuxMsg()
  1262.  
  1263. FUNCTION Gcd
  1264. *-------------------------------------------------------------------------------
  1265. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1266. *-- Date........: 12/03/1992
  1267. *-- Notes.......: Greatest common divisor of two integers.  Given two
  1268. *--               integers, returns their largest common divisor.  Returns
  1269. *--               0 if one or both are not integers, but returns the
  1270. *--               absolute value of the gcd if one or both are negative.
  1271. *--               If one is 0, returns the other.
  1272. *--                   Usually known as "Euclid's algorithm."
  1273. *--                   The algorithm used is discussed in 4.5.2 of
  1274. *--               Volume II, "The Art of Computer Programming", 2d edition,
  1275. *--               Addison-Wesley, Reading, MA, by Donald Knuth.
  1276. *-- Written for.: dBASE IV, 1.1 and 1.5
  1277. *-- Rev. History: None
  1278. *-- Calls.......: None
  1279. *-- Called by...: Any
  1280. *-- Usage.......: Gcd( <n1>, <n2> )
  1281. *-- Example.....: ?  Gcd( 24140, 40902 )
  1282. *-- Returns.....: numeric, the Gcd, or 0 if not both integers ( 34 in example).
  1283. *-- Parameters..: n1       = numeric, one of the integers
  1284. *--               n2       = numeric, the other
  1285. *-------------------------------------------------------------------------------
  1286.  
  1287.    parameters n1, n2
  1288.  
  1289.    private nMin, nMax, nMod
  1290.  
  1291.    nMax = iif( int( n1 ) = n1 .and. int( n2 ) = n2, 1, 0 )
  1292.  
  1293.    if nMax # 0
  1294.      nMin = min( abs( n1 ), abs( n2 ) )
  1295.      nMax = max( abs( n1 ), abs( n2 ) )
  1296.  
  1297.      do while nMin > 0
  1298.        nMod = mod( nMax, nMin )
  1299.        nMax = nMin
  1300.        nMin = nMod
  1301.      enddo
  1302.    endif
  1303.  
  1304. RETURN nMax
  1305. *-- EoF: Gcd()
  1306.  
  1307. FUNCTION RandSel
  1308. *-------------------------------------------------------------------------------
  1309. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1310. *-- Date........: 12/03/1992
  1311. *-- Notes.......: Random selection of integers.  The function requires
  1312. *--               two numeric parameters, the number nN to select and the
  1313. *--               number of items nT to select from.  It fills the first
  1314. *--               nN rows of a one-column array with an ordered random
  1315. *--               selection of the integers from 1 to nT, which may of
  1316. *--               course be used as record numbers or indices into some
  1317. *--               other data structure to select items from it.  If
  1318. *--               passed a third, character, parameter, it will place the
  1319. *--               selected numbers in the array of that name, otherwise in
  1320. *--               the array "RandSel".  If passed a fourth parameter
  1321. *--               that evaluates to .T., it will reseed the random number
  1322. *--               generator, otherwise use the next random numbers.
  1323. *--                   If the array does not exist, it will be created.  If
  1324. *--               it does exist but with two dimensions or too few rows,
  1325. *--               it will be recreated with one dimension and enough rows.
  1326. *--               If the first parameter is larger than the second, they
  1327. *--               will be swapped.
  1328. *--                   The random-number generator should usually be reseeded,
  1329. *--               either by using the "lReseed" parameter or before calling
  1330. *--               the function, except where the function is being called
  1331. *--               repeatedly either within a very short time or for related
  1332. *--               applications in which a repetition of the sequence would
  1333. *--               defeat the randomness.
  1334. *--                   For dBASE IV versions before 1.5, revise this to take
  1335. *--               only the two numeric parameters by commenting out the first
  1336. *--               "parameters" line of code below and including the next
  1337. *--               three commented lines.  The array "RandSel" will be used,
  1338. *--               and reseeding if needed must be done before calling the
  1339. *--               function.
  1340. *--                   The algorithm used is "Algorithm S" discussed
  1341. *--               in 3.4.2 of Volume II, "The Art of Computer Programming",
  1342. *--               2d edition, Addison-Wesley, Reading, MA, by Donald Knuth.
  1343. *-- Written for.: dBASE IV, 1.1 and 1.5
  1344. *-- Rev. History: None
  1345. *-- Calls.......: None
  1346. *-- Called by...: Any
  1347. *-- Usage.......: RandSel( "<nN>,<nT> [,<cArray>] [,<lReseed>]" )
  1348. *-- Example.....: lX = RandSel( 100, reccount(), "MyArray", .T. )
  1349. *-- Returns.....: .T. if successful, or .F. if given number < 1 as parameter.
  1350. *-- Parameters..: nN       = numeric, number of integers to select
  1351. *--               nT       = numeric, highest integer to select from
  1352. *--               cArray   = character, name of the array to hold the
  1353. *--                          selected integers.  If not furnished, array
  1354. *--                          "RandSel" will be used.
  1355. *--               lReseed  = logical, .T. to reseed the random-number
  1356. *--                          generator.  Default is .F., no reseed.
  1357. *-- Side effects: Creates as needed and fills the array.
  1358. *--               Uses some random numbers from the sequence.
  1359. *-------------------------------------------------------------------------------
  1360.  
  1361.    parameters nN, nT, cArray, lReseed
  1362.  
  1363. *-- users of versions below 1.5, comment out the line above and include
  1364. *-- the three lines below
  1365.  
  1366. *   parameters nN, nT
  1367. *   private cArray, lReseed
  1368. *   store .F. to cArray, lReseed
  1369.  
  1370.    private nChoose, nTotal, lReturn, nX, nChosen, nSeen
  1371.  
  1372.    nChoose = int( min( nN, nT ) )
  1373.    nTotal = int( max( nN, nT ) )
  1374.    lReturn = ( nChoose >= 1 )
  1375.  
  1376.    if lReturn
  1377.      if type( "cArray" ) = "L"
  1378.        cArray = "RandSel"
  1379.      endif
  1380.  
  1381.      if type( "&cArray.[ nT ]" ) = "U"
  1382.        release &cArray
  1383.        public &cArray
  1384.        declare &cArray.[ nT ]
  1385.      endif
  1386.  
  1387.      if lReseed
  1388.        nX = rand( -1 )
  1389.      endif
  1390.  
  1391.      store 0 to nChosen, nSeen
  1392.      do while nChosen < nChoose
  1393.        nX = rand() * ( nTotal - nSeen )
  1394.        if nX < nChoose - nChosen
  1395.          nChosen = nChosen + 1
  1396.          &cArray.[ nChosen ] = nSeen + 1
  1397.        endif
  1398.        nSeen = nSeen + 1
  1399.      enddo
  1400.    endif
  1401.  
  1402. RETURN lReturn
  1403. *-- EoF: RandSel()
  1404.  
  1405. *-------------------------------------------------------------------------------
  1406. *-- EoP: MISC.PRG
  1407. *-------------------------------------------------------------------------------
  1408.